home *** CD-ROM | disk | FTP | other *** search
/ The Programmer Disk / The Programmer Disk (Microforum).iso / xpro / qb2 / pro15 / ball.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-08-20  |  4.1 KB  |  179 lines
  1. {
  2.  ******************************************************************************
  3.  * BALL - Bouncing ball animation demo using XOR option.              *
  4.  *                                          *
  5.  * Written for GRAFIX by:  Joseph A. Albrecht                      *
  6.  *                                          *
  7.  * Press ESC to exit program                              *
  8.  * Press F3 to toggle sound on/off                          *
  9.  * Press F5 to toggle clipping mode                          *
  10.  * Press F10 to toggle between 320 and 640 graphics modes              *
  11.  ******************************************************************************
  12. }
  13.  
  14. PROGRAM BouncingBall;
  15.  
  16. USES
  17.   Crt,
  18.   Grafix;
  19.  
  20. TYPE
  21.   Note = ARRAY [1..84] OF INTEGER;
  22.  
  23. VAR
  24.   Graphics, XOffset, Clip, D, E, J, K, L, N, S, X, X2, Y, Y2: INTEGER;
  25.   Tandy11, Loop, EndProgram, DoSound: BOOLEAN;
  26.   BALL: ARRAY [0..115] OF WORD;
  27.   B: ARRAY [0..280] OF INTEGER;
  28.  
  29. CONST
  30.   Notes:
  31.     Note =
  32.       (65,69,73,78,82,87,93,98,104,110,116,123,131,139,147,156,165,175,185,196,
  33.        208,220,233,247,262,277,294,311,330,349,370,392,415,440,466,494,523,554,
  34.        587,622,659,698,740,784,831,880,932,988,1047,1109,1175,1245,1319,1397,
  35.        1480,1568,1661,1760,1865,1976,2091,2217,2349,2489,2637,2794,2960,3136,
  36.        3322,3520,3729,3951,4186,4435,4699,4978,5274,5587,5919,6271,6645,7040,
  37.        7459,7902);
  38.  
  39. PROCEDURE CheckKey;
  40.  
  41. VAR
  42.   Ch: CHAR;
  43.  
  44. BEGIN
  45.  
  46.   Ch := #255;
  47.   IF KeyPressed THEN
  48.     Ch := ReadKey;
  49.   IF Ch = #27 THEN
  50.      BEGIN
  51.        Loop := False;
  52.        EndProgram := True;
  53.      END;
  54.   IF Ch = #00 THEN
  55.     BEGIN
  56.       Ch := ReadKey;
  57.       IF Ch = #61 THEN
  58.     IF DoSound = True THEN
  59.       DoSound := False
  60.     ELSE
  61.       DoSound := True;
  62.       IF Ch = #63 THEN
  63.     BEGIN
  64.       Loop := False;
  65.       IF Clip = 1 THEN
  66.         Clip := 0
  67.       ELSE
  68.         Clip := 1;
  69.     END;
  70.       IF (Ch = #68) AND (Tandy11 = True) THEN
  71.     BEGIN
  72.       IF Graphics = 320 THEN
  73.         BEGIN
  74.           Graphics := 640;
  75.           XOffset := 160;
  76.           Loop := False;
  77.           HighGraphics;
  78.         END
  79.       ELSE
  80.          BEGIN
  81.            Graphics := 320;
  82.            XOffset := 0;
  83.            Loop := False;
  84.            MediumGraphics;
  85.          END;
  86.     END;
  87.     END;
  88.  
  89. END;
  90.  
  91. {Mainline}
  92. BEGIN
  93.  
  94.   Graphics := 320;
  95.   XOffset := 0;
  96.   Clip := 0;
  97.   DoSound := True;
  98.   Loop := True;
  99.   EndProgram := False;
  100.   GetTandy11(Tandy11);
  101.   FOR X := 0 TO 280 DO
  102.     B[X] := 0;
  103.   X := 20;
  104.   WHILE X <= 280 DO
  105.     BEGIN
  106.       B[X] := Round(159 - (Abs(Sin(X * 0.07853981) * X) / 2));
  107.       Inc(X, 4);
  108.     END;
  109.   MediumGraphics;
  110.  
  111. WHILE EndProgram = False DO
  112.   BEGIN
  113.     ResetView;
  114.     ClearScreen;
  115.     SetBackColor(LightGray);
  116.     ExtCircleC(160, 100, 10, DarkGray);
  117.     ExtPaint(160, 100, DarkGray, DarkGray);
  118.     ExtGet(150, 90, 170, 110, Ball[0]);
  119.     ClearScreen;
  120.     DrawBox(18 + XOffset, 0, 302 + XOffset, 179, Red);
  121.     DrawBox(19 + XOffset, 1, 301 + XOffset, 178, Red);
  122.     IF Clip = 1 THEN
  123.       BEGIN
  124.     DrawBox(79 + XOffset, 74, 241 + XOffset, 151, Blue);
  125.     DrawBox(78 + XOffset, 73, 242 + XOffset, 152, Blue);
  126.     SetView(80 + XOffset, 75, 240 + XOffset, 150);
  127.       END;
  128.     FillBox(160 + XOffset, 2, 190 + XOffset, 177, LightBlue);
  129.     FillBox(191 + XOffset, 2, 222 + XOffset, 177, LightRed);
  130.     FillBox(223 + XOffset, 2, 253 + XOffset, 177, Yellow);
  131.     L := 6;
  132.     X2 := 20;
  133.     Y2 := 150;
  134.     ExtPut(X2 + XOffset, Y2, Ball[0], PutXor);
  135.     WHILE Loop = True DO
  136.      BEGIN
  137.        FOR D := 0 TO 1 DO
  138.      BEGIN
  139.        S := (20 + (D * 260));
  140.        E := (280 - (D * 260));
  141.        X := S;
  142.        J := S;
  143.        K := E;
  144.        IF D = 1 THEN
  145.          BEGIN
  146.            K := S;
  147.            J := E;
  148.          END;
  149.        WHILE (J <= K) AND (Loop = True) DO
  150.          BEGIN
  151.            Y := B[X];
  152.            ExtPut(X2 + XOffset, Y2, Ball[0], PutXor);
  153.            ExtPut(X + XOffset, Y, Ball[0], PutXor);
  154.            N := (210 - Y2) Div 5;
  155.            IF DoSound = True THEN
  156.          ExtSound(Notes[N], Round(21.0 / L * 0.875), 10, 0)
  157.            ELSE
  158.          Pause(Round(21.0 / L * 0.875));
  159.            X2 := X;
  160.            Y2 := Y;
  161.            X := X + (4 - (8 * D));
  162.            IF D = 0 THEN
  163.          J := X
  164.            ELSE
  165.          K := X;
  166.            CheckKey;
  167.          END;
  168.        L := L + 3;
  169.        IF L > 21 THEN
  170.          L := 6;
  171.      END;
  172.      END;
  173.      IF EndProgram = False THEN
  174.        Loop := True;
  175.   END;
  176.   ExitGraphics;
  177.  
  178. END.
  179.